home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / TSPA3340.ZIP / TSUNTD.TST < prev    next >
Text File  |  1993-01-23  |  6KB  |  262 lines
  1. {$R+}  (* Index range check on *)
  2.  
  3. (* This is a test program for the TSUNTD.TPU unit
  4.    2-Aug-89, Updated 25-Sep-89, 13-Jun-90, 15-Jul-90, 5-Jan-91,
  5.    23-Jan-93 *)
  6.  
  7. uses TSUNTB,
  8.      TSUNTD;
  9.  
  10. const loop = 200;   (* If you do want to make it quickly, change this to 1 *)
  11.  
  12. var time : real;    (* For timing the tests *)
  13.  
  14. procedure LOGO;
  15. begin
  16.   writeln;
  17.   writeln ('TSUNTD unit test by Prof. Timo Salmi');
  18.   writeln ('University of Vaasa, Finland, ts@uwasa.fi');
  19. {$IFDEF VER40}
  20.   writeln ('TP version 4.0');
  21. {$ENDIF}
  22. {$IFDEF VER50}
  23.   writeln ('TP version 5.0');
  24. {$ENDIF}
  25. {$IFDEF VER55}
  26.   writeln ('TP version 5.5');
  27. {$ENDIF}
  28. {$IFDEF VER60}
  29.   writeln ('TP version 6.0');
  30. {$ENDIF}
  31. {$IFDEF VER70}
  32.   writeln ('TP version 7.0');
  33. {$ENDIF}
  34.   writeln;
  35. end;
  36.  
  37. (* Dosdelay function, no Ctr unit needed *)
  38. procedure TEST1;
  39. begin
  40.   time := TIMERFN;
  41.   DOSDELAY (1000);
  42.   time := TIMERFN - time;
  43.   writeln ('DOSDELAY(1000)');
  44.   writeln ('Elapsed ', time:0:2);
  45.   writeln;
  46. end;  (* test1 *)
  47.  
  48. (* Justify a string right *)
  49. procedure TEST2;
  50. var sj1, sj2 : string;
  51.     i        : word;
  52. begin
  53.   writeln ('....:....1....:....2....:....3....:....4....:....5....');
  54.   sj1 := 'TSUNTD';
  55.   time := TIMERFN;
  56.   for i := 1 to loop do sj2 := TRIMRGFN (sj1, 20);
  57.   time := TIMERFN - time;
  58.   writeln (sj1); writeln (sj2);
  59.   writeln ('Elapsed ', time:0:2);
  60. end;  (* test2 *)
  61.  
  62. procedure TEST3;
  63. var sj1, sj2 : string;
  64.     i        : word;
  65. begin
  66.   writeln ('....:....1....:....2....:....3....:....4....:....5....');
  67.   sj1 := 'TSUNTD';
  68.   time := TIMERFN;
  69.   for i := 1 to loop do sj2 := TRIMRGFN (sj1, 4);
  70.   time := TIMERFN - time;
  71.   writeln (sj1); writeln (sj2);
  72.   writeln ('Elapsed ', time:0:2);
  73. end;  (* test3 *)
  74.  
  75. (* Justify a string left *)
  76. procedure TEST4;
  77. var sj1, sj2 : string;
  78.     i        : word;
  79. begin
  80.   writeln ('....:....1....:....2....:....3....:....4....:....5....');
  81.   sj1 := '     TSUNTD';
  82.   time := TIMERFN;
  83.   for i := 1 to loop do sj2 := TRIMLFFN (sj1, 20);
  84.   time := TIMERFN - time;
  85.   writeln (sj1); writeln (sj2);
  86.   writeln ('Elapsed ', time:0:2);
  87. end;  (* test4 *)
  88.  
  89. procedure TEST5;
  90. var sj1, sj2 : string;
  91.     i        : word;
  92. begin
  93.   writeln ('....:....1....:....2....:....3....:....4....:....5....');
  94.   sj1 := '     TSUNTD';
  95.   time := TIMERFN;
  96.   for i := 1 to loop do sj2 := TRIMLFFN (sj1, 4);
  97.   time := TIMERFN - time;
  98.   writeln (sj1); writeln (sj2);
  99.   writeln ('Elapsed ', time:0:2);
  100. end;  (* test5 *)
  101.  
  102. (* Lead a string *)
  103. procedure TEST6;
  104. var sj1, sj2 : string;
  105.     i        : word;
  106. begin
  107.   writeln ('....:....1....:....2....:....3....:....4....:....5....');
  108.   sj1 := 'TSUNTD';
  109.   time := TIMERFN;
  110.   for i := 1 to loop do sj2 := LEADFN (sj1, 20, '.');
  111.   time := TIMERFN - time;
  112.   writeln (sj1); writeln (sj2);
  113.   writeln ('Elapsed ', time:0:2);
  114. end;  (* test6 *)
  115.  
  116. (* Trail a string *)
  117. procedure TEST7;
  118. var sj1, sj2 : string;
  119.     i        : word;
  120. begin
  121.   writeln ('....:....1....:....2....:....3....:....4....:....5....');
  122.   sj1 := 'TSUNTD';
  123.   time := TIMERFN;
  124.   for i := 1 to loop do sj2 := TRAILFN (sj1, 20, '.');
  125.   time := TIMERFN - time;
  126.   writeln (sj1); writeln (sj2);
  127.   writeln ('Elapsed ', time:0:2);
  128. end;  (* test7 *)
  129.  
  130. (* Extract all substrings from a string *)
  131. procedure TEST8;
  132. {$IFNDEF VER40}
  133. const separators : string = ' ' + ',' + #9;
  134. {$ENDIF}
  135. var sj      : string;
  136.     partPtr : parseVectorPtrType;
  137.     n       : integer;
  138.     ok      : boolean;
  139.     i       : byte;
  140. {$IFDEF VER40} var separators : string; {$ENDIF}
  141. begin
  142.   {$IFDEF VER40} separators := ' ' + ',' + #9; {$ENDIF}
  143.   New (partPtr);
  144.   sj := 'TSUNTD unit test by Prof. Timo Salmi';
  145.   PARSE (sj, parse_parts_max, separators,
  146.          n, partPtr, ok);
  147.   if not ok then halt;   {or whatever you want do in case of an error}
  148.   for i := 1 to n do writeln (partPtr^[i]);
  149.   Dispose (partPtr); partPtr := nil;
  150. end;  (* test8 *)
  151.  
  152. (* Alternative method: Extract all substrings from a string *)
  153. procedure TEST9;
  154. var sj      : string;
  155.     n       : integer;
  156.     i       : byte;
  157. var separators : string;
  158. begin
  159.   separators := ' ' + ',' + #9;
  160.   sj := 'TSUNTD unit test by Prof. Timo Salmi';
  161.   n := STRCNTFN (sj, separators);
  162.   for i := 1 to n do writeln (SPARTFN(sj, separators, i));
  163. end;  (* test9 *)
  164.  
  165. (* How does it sound *)
  166. procedure TEST10;
  167. begin
  168.   AUDIO (300, 300); DOSDELAY(20); AUDIO (300, 300); AUDIO (400, 600);
  169. end;  (* test10 *)
  170.  
  171. (* Printer status retort *)
  172. procedure TEST11;
  173. begin
  174.   if PRTONLFN then
  175.     writeln ('Printer ready')
  176.   else
  177.     writeln ('Printer not ready');
  178. end;  (* test11 *)
  179.  
  180. (* Printer status retort, the second method *)
  181. procedure TEST12;
  182. begin
  183.   if LPTONLFN then
  184.     writeln ('Second test: Printer ready')
  185.   else
  186.     writeln ('Second test: Printer not ready');
  187. end;  (* test12 *)
  188.  
  189. (* Print screen *)
  190. procedure TEST13;
  191. begin
  192.   if LPTONLFN then
  193.     PRTSCR
  194.   else
  195.     writeln ('Can''t print the screen: Printer not ready');
  196. end;  (* test13 *)
  197.  
  198. (* Convert to lower case *)
  199. procedure TEST14;
  200. var str : string;
  201.     i,p : byte;
  202. begin
  203.   str := 'Lets See if This Works: ABC XYZ 123 890 fred *?';
  204.   writeln (str);
  205.   p := Length(str);
  206.   i := 1;
  207.   while i <= p do begin
  208.     write (LOWCASFN(str[i]));
  209.     Flush (output);
  210.     Inc(i);
  211.   end;
  212.   writeln;
  213. end;  (* test14 *)
  214.  
  215. (* The current default number of printer retrys before I/O error *)
  216. procedure TEST15;
  217. begin
  218.   writeln ('Printer default retrys = ', GETPRTFN, ' times');
  219.   Flush (output);
  220. end; (* test15 *)
  221.  
  222. (* Number of substrings in a string *)
  223. procedure TEST16;
  224. var s, s1 : string;
  225.     n, i  : integer;
  226.     time  : real;
  227. begin
  228.   repeat
  229.     write ('Give a string (exit to end): '); readln (s);
  230.     writeln ('Number of substrings = ', n);
  231.     for i := 1 to n do
  232.       writeln (PARSERFN (s, i));
  233.   until s = 'exit';
  234. end;  (* test16 *)
  235.  
  236. (* Main program *)
  237. begin
  238.   {}
  239.   LOGO;
  240.   TEST11;
  241.   TEST12;
  242.   TEST13;
  243.   {... Comment the halt away if you want the rest of the tests ...}
  244.   halt;
  245.   {}
  246.   TEST10;
  247.   TEST1;
  248.   TEST2;
  249.   TEST3;
  250.   TEST4;
  251.   write ('Press «═╝ '); readln;
  252.   TEST5;
  253.   TEST6;
  254.   TEST7;
  255.   write ('Press «═╝ '); readln;
  256.   TEST8;
  257.   write ('Press «═╝ '); readln;
  258.   TEST9;
  259.   TEST14;
  260.   TEST15;
  261. end.  (* tsuntd.tst *)
  262.